home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Toolbox / Visual Basic Toolbox (P.I.E.)(1996).ISO / tpascal / vbxwz / samples / bmpfilm.pas next >
Encoding:
Pascal/Delphi Source File  |  1994-12-13  |  9.0 KB  |  223 lines
  1. {---------------------------------------------}
  2. { This program create DLL file                }
  3. { (custom control) for Visual Basic           }
  4. {---------------------------------------------}
  5. library BmpFilm;
  6. {$R BMPFILM.RES}
  7. uses WinTypes,WinProcs,BPVBAPI,Strings;
  8. {---------------------------------------------}
  9. { BmpFilm control data and structs            }
  10. {---------------------------------------------}
  11. type PBmpFilm=^TBmpFilm;
  12.      TBmpFilm=record
  13.        Cols:Integer;     {Property 'Cols'}
  14.        Rows:Integer;     {Property 'Rows'}
  15.        Bitmap:HPic;      {Property 'Bitmap'}
  16.        Interval:Integer; {Property 'Interval'}
  17.      end;
  18. {------------------------------}
  19. { Set new Item in Property     }
  20. {------------------------------}
  21. const Property_Cols:TPROPINFO=(
  22.       npszName:NPnt(PChar('Cols'));
  23.       fl:DT_Short or PF_fGetMsg or PF_fSetMsg or PF_fGetData or PF_fSetData or PF_fSaveData;
  24.       offsetData:Byte(0);
  25.       infoData:0;
  26.       dataDefault:0;
  27.       npszEnumList:0;
  28.       enumMax:0);
  29.       Property_Rows:TPROPINFO=(
  30.       npszName:NPnt(PChar('Rows'));
  31.       fl:DT_Short or PF_fGetMsg or PF_fSetMsg or PF_fGetData or PF_fSetData or PF_fSaveData;
  32.       offsetData:Byte(2);
  33.       infoData:0;
  34.       dataDefault:0;
  35.       npszEnumList:0;
  36.       enumMax:0);
  37.       {Property Item 'Bitmap'}
  38.       Property_Bitmap:TPROPINFO=(
  39.       npszName:NPnt(PChar('Bitmap'));
  40.       fl:DT_Picture or PF_fGetData or PF_fSetData or PF_fSetMsg or PF_fSaveData;
  41.       offsetData:Byte(4);
  42.       infoData:0;
  43.       dataDefault:0;
  44.       npszEnumList:0;
  45.       enumMax:0);
  46.       {Property Item 'Interval'}
  47.       Property_Interval:TPROPINFO=(
  48.       npszName:NPnt(PChar('Interval'));
  49.       fl:DT_Short or PF_fGetMsg or PF_fSetMsg or PF_fGetData or PF_fSetData or PF_fSaveData;
  50.       offsetData:Byte(6);
  51.       infoData:0;
  52.       dataDefault:0;
  53.       npszEnumList:0;
  54.       enumMax:0);
  55. {------------------------------}
  56. { Set all Property             }
  57. {------------------------------}
  58.       PropListBmpFilm:array[0..13]of PPROPINFO=(
  59.       PPROPINFO_STD_CTLNAME,          {0}
  60.       PPropInfo(@Property_Cols),      {1}
  61.       PPropInfo(@Property_Rows),      {2}
  62.       PPropInfo(@Property_Bitmap),    {3}
  63.       PPropInfo(@Property_Interval),  {4}
  64.       PPROPINFO_STD_ENABLED,
  65.       PPROPINFO_STD_INDEX,
  66.       PPROPINFO_STD_LEFT,
  67.       PPROPINFO_STD_TOP,
  68.       PPROPINFO_STD_WIDTH,
  69.       PPROPINFO_STD_HEIGHT,
  70.       PPROPINFO_STD_VISIBLE,
  71.       PPROPINFO_STD_TAG,
  72.       0);
  73. {------------------------------------------------}
  74. { Event procedure parameter prototypes           }
  75. { Event list                                     }
  76. { Define the consecutive indicies for the events }
  77. {------------------------------------------------}
  78.       Event_Change:TEVENTINFO=(
  79.       npszName:NPnt(PChar('Change'));
  80.       cParms:0;
  81.       cwParms:0;
  82.       npParmTypes:0;
  83.       npszParmProf:NPnt(PChar(''));
  84.       fl:0);
  85.       EventListBmpFilm:array[0..2]of PEVENTINFO=(
  86.       PEventInfo(@Event_Change),
  87.       PEVENTINFO_STD_MOUSEMOVE,
  88.       0);
  89. {------------------------------}
  90. { Constans and Variables       }
  91. {------------------------------}
  92. var Pic:TPic;         {Picture-Bitmap}
  93.     Interval:Integer; {Interval}
  94.     Col,Row,Cols,Rows:Integer;{Col,Row,Cols and Rows}
  95.     Width,Height:Word;{Width and Height of Bitmap}
  96.     MemDC:hDC;        {MemDc}
  97. {------------------------------------------------}
  98. { Paint the BackGround from Bitmap               }
  99. {------------------------------------------------}
  100. procedure PaintBitmap(Wnd:hWnd;NewDC:hDC);
  101. const hbrOld:hBrush=0;
  102. var hBR:hBrush;
  103. begin
  104.     hBR:=GetBrushOrg(NewDC);                           {Get brush}
  105.     if Bool(hbr) then hbrOld:=SelectObject(NewDC,hBR); {Select Object to Paint and Save old Brush}
  106.     MemDC:=CreateCompatibleDC(NewDC);                  {Put Bitmap to Memory}
  107.     SelectObject(MemDC,Pic.PicData.Bitmap);            {Select Object to Paint}
  108.     BitBlt(NewDC,0,0,Width,Height,MemDC,Col*Width,Row*Height,SrcCopy);{Show Bitmap in Window}
  109.     SelectObject(NewDC,hbrOld);                        {Restore old brush}
  110.     DeleteDC(MemDC);                                   {Delete Bitmap from Memory}
  111. end;
  112. function BmpFilmCtlProc(Control:HCtl;Wnd:HWnd;Msg,WParam:Word;LParam:LongInt):LongInt; export;
  113. var TP:TPaintStruct;
  114.     BMP:TBitmap;
  115.     Rec:TRect;
  116. begin
  117.   case Msg of
  118.     WM_CREATE:
  119.     begin
  120.       Pic.PicData.Bitmap:=0;                     {Set bitmap}
  121.       if VBGetMode=Mode_Design then
  122.         begin
  123.           Width:=32; Height:=32;                 {Set default Width and Height}
  124.           VBSetControlProperty(Control,1,6);     {Set control property 'Cols - 100'}
  125.           VBSetControlProperty(Control,2,3);     {Set control property 'Rows - 100'}
  126.         end;
  127.     end;
  128.     WM_TIMER:                                    {Next Picture}
  129.     begin
  130.       if Col=Cols-1 then
  131.         begin
  132.           Col:=0;                          {Set first Col}
  133.           Row:=Row+1;                      {Inc Row}
  134.         end
  135.       else Col:=Col+1;                     {Inc Cols}
  136.       if Row=Rows then
  137.         begin
  138.           Row:=0;                          {Set first Row}
  139.           Col:=0;                          {Set first Col}
  140.         end;
  141.       InvalidateRect(Wnd,nil,False);       {Paint New Bitmap}
  142.     end;
  143.     WM_PAINT:
  144.     begin
  145.       SetWindowPos(Wnd,0,0,0,Width,Height,Swp_NoMove);{Set just Window Size}
  146.       BeginPaint(Wnd,TP);                  {Begin Paint Bitmap}
  147.       PaintBitmap(Wnd,TP.hDC);             {Show the Bitmap}
  148.       VBFireEvent(Control,0,nil);          {Fire Event Change}
  149.       EndPaint(Wnd,TP);                    {End Paint Bitmap}
  150.       Exit;                                {Exit from Message}
  151.     end;
  152.     VBM_SETPROPERTY:                       {If Check item from Property}
  153.     begin
  154.       case wParam of
  155.         1,2:InvalidateRect(Wnd,nil,True);  {Paint Bitmap again}
  156.         3:                                 {'Bitmap'}
  157.         begin
  158.           VBGetPic(HPic(LParam),@Pic);
  159.           if Pic.picType=PICTYPE_BITMAP then {If Bitmap then}
  160.             begin
  161.               GetObject(Pic.PicData.Bitmap,sizeof(TBitMap),PChar(@Bmp)); {Get information of new BITMAP}
  162.               VBGetControlProperty(Control,1,@Cols);{Get Cols Property}
  163.               VBGetControlProperty(Control,2,@Rows);{Get Rows Property}
  164.               Width:=Bmp.bmWidth div Cols;  {Get width}
  165.               Height:=Bmp.bmHeight div Rows;{Get height}
  166.               Col:=0;                       {Set first Col}
  167.               Row:=0;                       {Set first Row}
  168.               InvalidateRect(Wnd,nil,True); {Paint Bitmap}
  169.             end
  170.           else
  171.             begin                          {Else exit on Error}
  172.               BmpFilmCtlProc:=380;         {'Invalid Property Value'}
  173.           Exit;
  174.             end;
  175.         end;
  176.         4:                                 {'Interval' Property}
  177.         begin
  178.           VBGetControlProperty(Control,4,@Interval);{Get Interval Property}
  179.           if VBGetMode=Mode_Run then SetTimer(Wnd,100,Interval,nil);
  180.         end;
  181.       end;
  182.     end;
  183.   end;
  184.   BmpFilmCtlProc:=VBDefControlProc(Control,Wnd,Msg,WParam,LParam);
  185.   if Msg=WM_DESTROY then begin KillTimer(Wnd,100); ReleaseDC(Wnd,MemDC); end;
  186. end;
  187. {--------------------------------------------}
  188. { Model struct                               }
  189. { Define the control model                   }
  190. { (using the event and property structures). }
  191. {--------------------------------------------}
  192. const   Model_BmpFilm:TMODEL=(
  193.     usVersion:VB_VERSION;               { VB version used by control}
  194.     fl:0;                                  { Bitfield structure}
  195.     ctlproc:TFarProc(@BmpFilmCtlProc);     { The control procudere.}
  196.     fsClassStyle:cs_VRedraw or cs_HRedraw; { Window class style}
  197.     flWndStyle:0;                        { Default window style}
  198.     cbCtlExtra:sizeof(TBmpFilm);           { # bytes alloc'd for HCTL structure}
  199.     idBmpPalette:8000;               { BITMAP id for tool palette}
  200.     DefCtlName:NPnt(PChar('BmpFilm'));     { Default control name prefix. Typecasts PChar to a NPnt.}
  201.     ClassName:NPnt(PChar('BmpFilm'));      { Visual Basic class name}
  202.     ParentClassName:0;               { Parent window class if subclassed}
  203.     proplist:ofs(PropListBmpFilm);         { Property list}
  204.     eventlist:ofs(EventListBmpFilm);       { Event list}
  205.     nDefProp:0;                       { Index of default property}
  206.     nDefEvent:0);                       { Index of default event}
  207. {----------------------------------------------}
  208. { Register custom control.                     }
  209. { This routine is called by VB when the custom }
  210. { control DLL is loaded for use.               }
  211. {----------------------------------------------}
  212. function VBINITCC(usVersion: Word; fRunTime: Boolean): Boolean; export;
  213. begin
  214.   VBINITCC:=VBRegisterModel(hInstance,Model_BmpFilm);
  215. end;
  216. {---------------------------------------------}
  217. { Export the Function and Procedures from DLL }
  218. {---------------------------------------------}
  219. exports
  220.   VBINITCC         index 2,
  221.   BmpFilmCtlProc   index 3;
  222. begin
  223. end. {End of program}